home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / support / utils.scm < prev   
Encoding:
Text File  |  1994-09-27  |  12.2 KB  |  468 lines  |  [TEXT/CCL2]
  1. ;;; utils.scm -- utility functions
  2. ;;;
  3. ;;; author :  Sandra Loosemore
  4. ;;; date   :  18 Nov 1991
  5. ;;;
  6. ;;; This file contains miscellaneous functions that are generally useful.
  7. ;;; If you find some missing feature from the base language, this is
  8. ;;; a good place to put it.  Common Lisp-style sequence functions are 
  9. ;;; an example of the sort of thing found here.
  10.  
  11.  
  12. ;;;=====================================================================
  13. ;;; Sequence functions
  14. ;;;=====================================================================
  15.  
  16. (define (vector-replace to-vec from-vec to start end)
  17.   (declare (type fixnum to start end)
  18.        (type vector to-vec from-vec))
  19.   (if (and (eq? to-vec from-vec)
  20.        (> to start))
  21.       ;; Right shift in place
  22.       (do ((from  (1- end) (1- from))
  23.        (to    (1- (+ to (- end start)))))
  24.       ((< from start) to-vec)
  25.       (declare (type fixnum from to))
  26.       (setf (vector-ref to-vec to) (vector-ref from-vec from))
  27.       (decf to))
  28.       ;; Normal case, left-to-right
  29.       (do ((from  start (1+ from)))
  30.       ((= from end) to-vec)
  31.       (declare (type fixnum from))
  32.       (setf (vector-ref to-vec to) (vector-ref from-vec from))
  33.       (incf to))))
  34.  
  35. (define (string-replace to-vec from-vec to start end)
  36.   (declare (type fixnum to start end)
  37.        (type string to-vec from-vec))
  38.   (if (and (eq? to-vec from-vec)
  39.        (> to start))
  40.       ;; Right shift in place
  41.       (do ((from  (1- end) (1- from))
  42.        (to    (1- (+ to (- end start)))))
  43.       ((< from start) to-vec)
  44.       (declare (type fixnum from to))
  45.       (setf (string-ref to-vec to) (string-ref from-vec from))
  46.       (decf to))
  47.       ;; Normal case, left-to-right
  48.       (do ((from  start (1+ from)))
  49.       ((= from end) to-vec)
  50.       (declare (type fixnum from))
  51.       (setf (string-ref to-vec to) (string-ref from-vec from))
  52.       (incf to))))
  53.  
  54. (define (string-fill string c start end)
  55.   (declare (type fixnum start end)
  56.        (type string string)
  57.        (type char c))
  58.   (do ((i start (1+ i)))
  59.       ((= i end) string)
  60.       (declare (type fixnum i))
  61.       (setf (string-ref string i) c)))
  62.  
  63. (define (string-position c string start end)
  64.   (declare (type fixnum start end)
  65.        (type string string)
  66.        (type char c))
  67.   (cond ((= start end) '#f)
  68.     ((char=? (string-ref string start) c) start)
  69.     (else
  70.      (string-position c string (1+ start) end))))
  71.  
  72. (define (string-position-not-from-end c string start end)
  73.   (declare (type fixnum start end)
  74.        (type string string)
  75.        (type char c))
  76.   (cond ((= start end) '#f)
  77.     ((not (char=? (string-ref string (setf end (1- end))) c))
  78.      end)
  79.     (else
  80.      (string-position-not-from-end c string start end))))
  81.  
  82. (define (string-nreverse string start end)
  83.   (declare (type fixnum start end)
  84.        (type string string))
  85.   (do ((i start (1+ i))
  86.        (j (1- end) (1- j)))
  87.       ((not (< i j)) string)
  88.       (declare (type fixnum i j))
  89.     (let ((c (string-ref string i)))
  90.       (setf (string-ref string i) (string-ref string j))
  91.       (setf (string-ref string j) c))))
  92.  
  93.  
  94. (define (string-starts? s1 s2)  ; true is s1 begins s2
  95.   (and (>= (string-length s2) (string-length s1))
  96.        (string=? s1 (substring s2 0 (string-length s1)))))
  97.  
  98.  
  99. ;;;=====================================================================
  100. ;;; Table utilities
  101. ;;;=====================================================================
  102.  
  103.  
  104. (define (table->list table)
  105.   (let ((l '()))
  106.        (table-for-each
  107.     (lambda (key val) (push (cons key val) l)) table)
  108.        l))
  109.  
  110. (define (list->table l)
  111.   (let ((table (make-table)))
  112.      (dolist (p l)
  113.     (setf (table-entry table (car p)) (cdr p)))
  114.      table))
  115.  
  116.  
  117.  
  118. ;;;=====================================================================
  119. ;;; Tuple utilities
  120. ;;;=====================================================================
  121.  
  122. ;;; For future compatibility with a typed language, define 2 tuples with
  123. ;;; a few functions:  (maybe add 3 tuples someday!)
  124.  
  125. (define-integrable (tuple x y)
  126.   (cons x y))
  127.  
  128. (define-integrable (tuple-2-1 x) (car x))  ; Flic-like notation
  129. (define-integrable (tuple-2-2 x) (cdr x))
  130.  
  131. (define (map-tuple-2-1 f l)
  132.   (map (lambda (x) (tuple (funcall f (tuple-2-1 x)) (tuple-2-2 x))) l))
  133.  
  134. (define (map-tuple-2-2 f l)
  135.   (map (lambda (x) (tuple (tuple-2-1 x) (funcall f (tuple-2-2 x)))) l))
  136.  
  137.  
  138. ;;;=====================================================================
  139. ;;; List utilities
  140. ;;;=====================================================================
  141.  
  142. ;;; This does an assq using the second half of the tuple as the key.
  143.  
  144. (define (rassq x l)
  145.   (if (null? l)
  146.       '#f
  147.       (if (eq? x (tuple-2-2 (car l)))
  148.       (car l)
  149.       (rassq x (cdr l)))))
  150.  
  151. ;;; This is an assoc with an explicit test
  152.  
  153. (define (assoc/test test-fn x l)
  154.   (if (null? l)
  155.       '#f
  156.       (if (funcall test-fn x (tuple-2-1 (car l)))
  157.       (car l)
  158.       (assoc/test test-fn x (cdr l)))))
  159.  
  160.  
  161.  
  162.  
  163. ;;; Stupid position function works only on lists, uses eqv?
  164.  
  165. (define (position item list)
  166.   (position-aux item list 0))
  167.  
  168. (define (position-aux item list index)
  169.   (declare (type fixnum index))
  170.   (cond ((null? list)
  171.      '#f)
  172.     ((eqv? item (car list))
  173.      index)
  174.     (else
  175.      (position-aux item (cdr list) (1+ index)))
  176.     ))
  177.  
  178.  
  179. ;;; Destructive delete-if function
  180.  
  181. (define (list-delete-if f l)
  182.   (list-delete-if-aux f l l '#f))
  183.  
  184. (define (list-delete-if-aux f head next last)
  185.   (cond ((null? next)
  186.      ;; No more elements.
  187.      head)
  188.     ((not (funcall f (car next)))
  189.      ;; Leave this element and do the next.
  190.      (list-delete-if-aux f head (cdr next) next))
  191.     (last
  192.      ;; Delete element from middle of list.
  193.      (setf (cdr last) (cdr next))
  194.      (list-delete-if-aux f head (cdr next) last))
  195.     (else
  196.      ;; Delete element from head of list.
  197.      (list-delete-if-aux f (cdr next) (cdr next) last))))
  198.  
  199. ;;; filter is a non-destructive version of delete
  200.  
  201. (define (filter f l)
  202.   (if (null? l)
  203.       '()
  204.       (if (funcall f (car l))
  205.       (cons (car l) (filter f (cdr l)))
  206.       (filter f (cdr l)))))
  207.  
  208. ;;; Same as the haskell function
  209.  
  210. (define (concat lists)
  211.   (if (null? lists)
  212.       '()
  213.       (append (car lists) (concat (cdr lists)))))
  214.  
  215.  
  216. ;;; This is a quick & dirty list sort function.
  217.  
  218. (define (sort-list l compare-fn)
  219.   (if (or (null? l) (null? (cdr l)))
  220.       l
  221.       (insert-sorted compare-fn (car l) (sort-list (cdr l) compare-fn))))
  222.  
  223. (define (insert-sorted compare-fn e l)
  224.   (if (null? l)
  225.       (list e)
  226.       (if (funcall compare-fn e (car l))
  227.       (cons e l)
  228.       (cons (car l) (insert-sorted compare-fn e (cdr l))))))
  229.  
  230. (define (find-duplicates l)
  231.   (cond ((null? l)
  232.      '())
  233.     ((memq (car l) (cdr l))
  234.      (cons (car l)
  235.            (find-duplicates (cdr l))))
  236.     (else (find-duplicates (cdr l)))))
  237.  
  238. ;;;  A simple & slow topsort routine.
  239. ;;;  Input:  A list of lists.  Each list is a object consed onto the
  240. ;;;          list of objects it preceeds.
  241. ;;;  Output: Two values: SORTED / CYCLIC & a list of either sorted objects
  242. ;;;                      or a set of components containing the cycle.
  243.  
  244. (define (topsort l)
  245.   (let ((changed? '#t)
  246.     (sorted '())
  247.     (next '()))
  248.     (do () ((not changed?) 
  249.         (if (null? next)
  250.         (values 'sorted (nreverse sorted))
  251.         (values 'cyclic (map (function car) next))))
  252.       (setf changed? '#f)
  253.       (setf next '())
  254.       (dolist (x l)
  255.         (cond ((topsort-aux (cdr x) sorted)
  256.            (push (car x) sorted)
  257.            (setf changed? '#t))
  258.           (else
  259.            (push x next))))
  260.       (setf l next))))
  261.  
  262.  
  263. ;;; Returns true if x doesn't contain any elements that aren't in sorted.
  264. ;;; equivalent to (null? (set-intersection x sorted)), but doesn't cons
  265. ;;; and doesn't traverse the whole list in the failure case.
  266.  
  267. (define (topsort-aux x sorted)
  268.   (cond ((null? x)
  269.      '#t)
  270.     ((memq (car x) sorted)
  271.      (topsort-aux (cdr x) sorted))
  272.     (else
  273.      '#f)))
  274.  
  275. (define (set-intersection s1 s2)
  276.   (if (null? s1)
  277.       '()
  278.       (let ((rest (set-intersection (cdr s1) s2)))
  279.     (if (memq (car s1) s2)
  280.         (cons (car s1) rest)
  281.         rest))))
  282.  
  283. ;;; remove s2 elements from s1
  284.  
  285. (define (set-difference s1 s2)
  286.   (if (null? s1)
  287.       '()
  288.       (let ((rest (set-difference (cdr s1) s2)))
  289.     (if (memq (car s1) s2)
  290.         rest
  291.         (cons (car s1) rest)))))
  292.  
  293.  
  294. (define (set-union s1 s2)
  295.   (if (null? s2)
  296.       s1
  297.       (if (memq (car s2) s1)
  298.       (set-union s1 (cdr s2))
  299.       (cons (car s2) (set-union s1 (cdr s2))))))
  300.  
  301.  
  302. ;;; Destructive list splitter
  303.  
  304. (define (split-list list n)
  305.   (declare (type fixnum n))
  306.   (let ((tail1  (list-tail list (1- n))))
  307.     (if (null? tail1)
  308.     (values list '())
  309.     (let ((tail2  (cdr tail1)))
  310.       (setf (cdr tail1) '())
  311.       (values list tail2)))))
  312.  
  313.  
  314. ;;; Some string utils
  315.  
  316. (define (mem-string s l)
  317.   (and (not (null? l)) (or (string=? s (car l))
  318.                (mem-string s (cdr l)))))
  319.  
  320. (define (ass-string k l)
  321.   (cond ((null? l)
  322.      '#f)
  323.     ((string=? k (caar l))
  324.      (car l))
  325.     (else
  326.      (ass-string k (cdr l)))))
  327.  
  328.  
  329. ;;;=====================================================================
  330. ;;; Syntax extensions
  331. ;;;=====================================================================
  332.  
  333. ;;; The mlet macro combines let* and multiple-value-bind into a single
  334. ;;; syntax.
  335.  
  336. (define-syntax (mlet binders . body)
  337.   (mlet-body binders body))
  338.  
  339. (define (mlet-body binders body)
  340.   (if (null? binders)
  341.       `(begin ,@body)
  342.       (let* ((b (car binders))
  343.          (var (car b))
  344.          (init (cadr b))
  345.          (inner-body (mlet-body (cdr binders) body)))
  346.     (if (pair? var)
  347.         (multiple-value-bind (new-vars ignore-decl)
  348.                  (remove-underlines var)
  349.            `(multiple-value-bind ,new-vars
  350.                      ,init ,@ignore-decl ,inner-body))
  351.         `(let ((,var ,init)) ,inner-body)))))
  352.  
  353. (define (remove-underlines vars)
  354.   (if (null? vars)
  355.       (values '() '())
  356.       (multiple-value-bind (rest ignore-decl) (remove-underlines (cdr vars))
  357.     (if (not (eq? (car vars) '_))
  358.         (values (cons (car vars) rest) ignore-decl)
  359.         (let ((var (gensym)))
  360.           (values (cons var rest)
  361.               `((declare (ignore ,var)) ,@ignore-decl)))))))
  362.  
  363.  
  364.  
  365.  
  366. ;;;=====================================================================
  367. ;;; Other utilities
  368. ;;;=====================================================================
  369.  
  370. (define (add-extension name ext)
  371.   (assemble-filename (filename-place name) (filename-name name) ext))
  372.  
  373. (define (time-execution thunk)
  374.   (let* ((start-time (get-run-time))
  375.      (res (funcall thunk))
  376.      (end-time (get-run-time)))
  377.     (values res (- end-time start-time))))
  378.  
  379. (define (pprint-flatten code . maybe-port)
  380.   (pprint-flatten-aux
  381.     code
  382.     (if (null? maybe-port) (current-output-port) (car maybe-port))))
  383.  
  384. (define (pprint-flatten-aux code port)
  385.   (if (and (pair? code)
  386.        (eq? (car code) 'begin))
  387.       (dolist (c (cdr code))
  388.     (pprint-flatten-aux c port))
  389.       (pprint*-aux code port)))
  390.  
  391. (define (print-flatten code port)
  392.   (if (and (pair? code)
  393.        (eq? (car code) 'begin))
  394.       (dolist (c (cdr code))
  395.     (print-flatten c port))
  396.       (begin
  397.     (internal-write code port)
  398.     (internal-newline port))))
  399.  
  400.  
  401. ;;; Like pprint, but print newline after instead of before.
  402.  
  403. (define (pprint* object . maybe-port)
  404.   (pprint*-aux
  405.     object
  406.     (if (null? maybe-port) (current-output-port) (car maybe-port))))
  407.  
  408. (define (pprint*-aux object port)
  409.   (dynamic-let ((*print-pretty*  '#t))
  410.     (prin1 object port))
  411.   (terpri port))
  412.  
  413. ;;; This reads stuff from a string.  (Better error checks needed!)
  414.  
  415. (define (read-lisp-object str)
  416.   (call-with-input-string str (lambda (port) (read port))))
  417.  
  418. ;;; This generates a list of distinct symbols
  419.  
  420. (define (gen-temp-names l)
  421.   (gen-temp-names-1 l '(A B C D E F G H I J K L M N O P Q R S)))
  422.  
  423. (define (gen-temp-names-1 l1 l2)
  424.   (if (null? l1)
  425.       '()
  426.       (if (null? l2)
  427.       (gen-temp-names-1 l1 (list (gensym "T")))
  428.       (cons (car l2) (gen-temp-names-1 (cdr l1) (cdr l2))))))
  429.  
  430. ;;; This is support for printing error messages.  This returns a string.
  431. ;;; If the object cannot be printed within the given width it is surrounded by 
  432. ;;; new-lines.
  433.  
  434. (define (format-sized obj size nl?)
  435.   (let ((r1 (format '#f (if nl? "~A~%" "~A ") obj)))
  436.     (if (<= (string-length r1) size)
  437.     r1
  438.     (block exit
  439.       (dolist (lev '(#f 4 3 2))
  440.       (let ((r (pretty-print-to-string obj lev)))
  441.         (when (or (eqv? lev 2) (< (string-length r) 300))
  442.            (return-from exit r))))))))
  443.  
  444. (define (pretty-print-to-string obj lev)
  445.   (dynamic-let ((*print-pretty* '#t)
  446.         (*print-level* lev))
  447.     (format '#f "~%~A~%" obj)))
  448.  
  449. (define (show-symbol-list l)
  450.   (show-symbol-list-1 l '#f))
  451.  
  452. (define (show-symbol-list/no-downcase l)
  453.   (show-symbol-list-1 l '#t))
  454.  
  455. (define (show-symbol-list-1 l dc?)
  456.   (call-with-output-string
  457.    (lambda (p)
  458.      (let ((s '#f))
  459.        (dolist (l1 l)
  460.       (if s
  461.           (write-string ", " p)
  462.           (setf s '#t))
  463.       (write-string
  464.        (if dc? (string-downcase (symbol->string l1)) (symbol->string l1))
  465.        p))))))
  466.  
  467.  
  468.